home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / System source / Base < prev    next >
Encoding:
Text File  |  1993-06-04  |  12.1 KB  |  472 lines  |  [TEXT/YERK]
  1. ( base  ==============================  June 12 84 )
  2. (  6/12/84  NDI Added DISK.SCR to front )
  3. (  8/15/84  CBD Added Select{ indexed case structure )
  4. ( 10/03/84  CBD Scon and other stuff )
  5. ( 10/08/84  CBD Added .h, .d, etc. )
  6. ( 10/12/84  CBD Added class error handling )
  7. ( 10/12/84  CBD Converted Variables to Values )
  8. ( 12/29/84  cbd Added resource string handling )
  9. ( 11/12/85  cdn Fixed nullOSstr; Msg# end with a CR )
  10. ( 12/20/85  cdn Made ascii sensitive to case )
  11. ( 12/12/85  cdn Corrected rDepth )
  12. (  2/21/86  cdn Changed file rewind to set EOF=0 in (save)
  13. (  6/18/86  cdn Added GetRes )
  14. (  6/26/86  cdn Added token )
  15. ( 10/09/86  cdn Modified next, for 2.0 nucleus )
  16. (  8/31/88    rfl changed extend to make it faster AND fixed >uc trap a054)
  17. (  7/10/90    rfl    modified getstring to return 0 0 if not found
  18. ( 12/24/90    rfl    changed the word BE to BI so that $be is valid.
  19. (  6/08/91  rfl    'type now works for upper and lower case
  20. ( 12/09/92    rfl    added switch to ?rdepth so that proc words don't have a problem if stack is
  21. (                  moved somewhere else in memory due to context switching
  22. (                  Actualy ?rdepth word moved to source Class
  23. (  5/01/93    rfl    added gestalt
  24. (  5/07/93    rfl    added asc>bin and bin>asc
  25. (  5/14/93    rfl    modified getstring to not open yerk.rsrc...error message if not found
  26.  
  27. Decimal
  28.  
  29. ( Ignore rest-of-line; a comment )
  30. : \  R> Drop ;    \ Exits to word that called Interpret
  31. Immediate
  32.  
  33. \ Display contents of return stack
  34. : trace r0 rp@ (.stack) ;
  35.  
  36. \ Mac File/Record Interface
  37. 4 constant cLen    \ length of a CFA
  38.  
  39. 0 constant nullVal
  40. : nullOSstr ' nullVal +base ;
  41.  
  42. \ ( -- ^wordstring )  retrieve next word from input stream
  43. : @word BL word here ;
  44.  
  45. Create not ' 0= here 4- !
  46.  
  47. : 0,  0 , ;    \ compile an empty cell
  48.  
  49. \ ( -- n )  parse a number from the input stream
  50. : @val  @word number drop ;
  51.  
  52. \ state-smart single cfa compiler
  53. : 'c @pfa cfa  state IF Compile lit , THEN ; Immediate
  54.  
  55. \ Leave code address on stack of word in input stream
  56. : 'Code     @pfa cfa @ [Compile] Literal ; Immediate
  57. 'code quit constant colCode
  58.  
  59. \ make latest word unfindable
  60. : smudge latest 32 toggle ; Immediate
  61.  
  62. \ ( -- 4bytestring )  OS type literal; both upper and lowercase
  63. : 'type
  64.     pad 4 bl fill  tib in + bl enclose (lcWord) here count 4 min
  65.     pad swap cmove  pad @ [Compile] literal
  66. ; Immediate
  67.  
  68. \ true if error; false if no error
  69. : gestalt ( -- response 0 or negativeErr ) [compile] 'type
  70.         state
  71.         IF  compile (gestalt)
  72.         ELSE (gestalt)
  73.         THEN ; immediate
  74.  
  75. \ some Forth83 compatible words
  76. Create >Link '  4- here 4- !    \ ( cfa -- lfa )
  77. Create Link> '  4+ here 4- !    \ ( lfa -- cfa )
  78. Create >Body '  4+ here 4- !    \ ( cfa -- pfa )
  79. Create Body> ' cfa here 4- !    \ ( pfa -- cfa )
  80. : Name>  pfa cfa ;                \ ( nfa -- cfa )
  81. : >Name  4+ nfa ;                \ ( cfa -- nfa )
  82.  
  83. \ Compile an inline string at addr
  84. : str,   c@ 1+ align allot  ;
  85.  
  86. 0 variable buf255 252 allot    \ buffer for string operations
  87.  
  88. \ Convert a string to a Str255 at buf leaving its absolute addr
  89. \ ( addr len addr -- abs:str255 )
  90. : >str255    >R dup R c! R 1+ swap cmove R> +base ;
  91. : Str255     buf255 >str255 ;
  92.  
  93. \ ( b -- )
  94. : Abort"  ?Comp  Compile (Ab")  word"  Str, ;  Immediate
  95.  
  96. \ State-smart HEX literal word - $ 30
  97. : $ Base   >R hex  @val
  98.     [Compile] literal   R> Put base ; Immediate
  99.  
  100. : w @val state
  101.     IF Compile wLitw w, ELSE makeInt THEN ; Immediate
  102.  
  103. hex 
  104. create extend 2017 w, 48c0 w, 2e80 w, $ 4EEB w,  next w,
  105. decimal
  106.  
  107. \ Define state-smart inline string literal
  108. : (lit")  R> count 2dup + align >R ;    \ runTime handler
  109.  
  110. \ ( -- addr len )
  111. : " state
  112.     IF Compile (lit")  word" str,
  113.     ELSE  word" buf255 over c@ 1+ cmove
  114.         buf255 count
  115.     THEN
  116. ; Immediate
  117.  
  118. \ Multiple code field support - see JFAR V1 #1, p.55
  119. \ 10/18/84  CBD  Version 1
  120.  
  121. ( #cfas seq# [prefix] -- addr #cfas nuseq# )
  122. : DO..
  123.     dup 8 > IF  , THEN    \ compile pfa of prefix
  124.     1- 2dup - 4* w,  Here  rot rot        \ (CODEFIELD)
  125.     'code dojmp Here 10 allot 10 cmove    \ DODO,
  126.     [Compile]  ]>  ;
  127.  
  128. \ end a DO.. construct
  129. : ..End Compile ;s  [Compile] <[ ; Immediate
  130.  
  131. \ Get inline code and compile it
  132. : (,code)
  133.     R> dup w@ swap 2+ swap
  134.     2dup + >R  Here swap dup allot cmove ;
  135.  
  136. \ ( addr len -- )  open resource file for name
  137. : OpenResFile
  138.     >R >R word0 R> R> str255
  139.     $ a997 trap  i->l    \ call OpenResFile
  140.     -1 = abort" resource file open failed" ;
  141.  
  142. \ open the yerk system resource file
  143. : openNR  " yerk.rsrc" OpenResFile ;
  144.  
  145. openNR
  146.  
  147. \ ( -- ascii )  Leave ascii val of next char in stream
  148. : Ascii
  149.     tib in + bl enclose (LCword)
  150.     here 1+ c@ [Compile] literal
  151. ; Immediate
  152.  
  153. \ ( resID -- addr len) get the string with resource ID
  154. : getString
  155.     0 swap makeint $ a9ba trap    \ call getString
  156.     dup 0= IF ." GetString Failed" type abort THEN
  157.     >ptr count ;
  158.  
  159. \ ( strID -- )  print string and abort
  160. : die
  161.     ." Error# " dup . ascii : emit
  162.     getString type 5 beep abort ;
  163.  
  164. \ ( nfa -- )  print a name field, filter out garbage
  165. : .name
  166.     count $ 5f and dup 16 >
  167.     IF 2drop ." ??? "
  168.     ELSE type space
  169.     THEN ." ::" ;
  170.  
  171. \ ( b -- ) abort with string whose resID is at IP
  172. : (.rAbort)
  173.     w@(IP) swap
  174.     IF cr ." In " R> drop R cLen - @ >name .name die
  175.     ELSE drop
  176.     THEN ;
  177.  
  178. \ ( b -- ) abort and print resource string if true. use: ?error str#
  179. : ?Error  Compile (.rAbort) @val w, ; Immediate
  180.  
  181. \ ( -- )  print string whose resID is at IP
  182. : (.tStr)  w@(IP) getString type ;
  183.  
  184. \ ( -- )  print string for id# in stream
  185. : type#  Compile (.tStr) @val w, ; Immediate
  186.  
  187. \ ( -- )  print string whose resID is at IP
  188. : (.rStr)  w@(IP) ." Msg# " dup . ascii : emit getString type cr ;
  189.  
  190. \ ( -- )  print " Msg#" & string for id# in stream
  191. : msg#  Compile (.rStr) @val w, ; Immediate
  192.  
  193. \ build a dictionary header without a cfa
  194. : header   create -4 allot ;
  195.  
  196. : Build
  197.     ?error 169    \ not enough codefields
  198.     Compile header  Compile (,code)
  199.     dup 4* W,  0 DO , LOOP
  200. ; Immediate
  201.  
  202. : CodeFields dup ;
  203.  
  204. \  ================ Resources ===========
  205.  
  206. \ ( resID type -- handle )  GetRes support word
  207. : (GetRes)  0 swap rot makeInt $ a9a0 trap ;    \ call GetResource
  208.  
  209. \ ( resID : type -- handle )  Load the resource from the resource file chain
  210. : GetRes
  211.     [Compile] 'type
  212.     state IF Compile (GetRes)
  213.         ELSE (GetRes) THEN
  214. ; Immediate
  215.  
  216. \ Resource support - use: 'type TYPE 1 rsrc sam
  217. 1 codefields
  218.  
  219. \ ( -- ^res ) get the resource into memory
  220.     Do..  dup 4+ w@ swap @ (GetRes)
  221.         dup 0= ?error 170    \ getResource Failed
  222.         >ptr  ..End
  223.  
  224. : rsrc  Build  swap , w,  ..End
  225.  
  226. \ Force printing in hex or decimal
  227. ( n -- )
  228. : .H  base >R  hex     . R> Put base ;
  229. : .D  base >R  decimal . R> Put base ;
  230.  
  231. \ ( -- )  Goto threaded code  whose addr in next dict cell
  232. : (Jmp)  R> @ >R ;
  233.  
  234. \ ( newPfa oldPfa -- )  Patch pfa at old  to exec new
  235. : (patch)
  236.     >R  colCode  R cfa !  'c (jmp) R !
  237.     R> clen  + ! ;
  238.  
  239. \ Patch a word to a newly defined word
  240. \ Use:  Patch oldWord newWord
  241. : Patch   @pfa  @pfa swap  (patch) ; Immediate
  242.  
  243. \  Forward referencing support
  244. \ ( -- )  declare a new forward reference
  245. : Forward
  246.     <Builds  0,
  247.     Does> cr  msg# 109   cLen -
  248.         nfa  .name  R .h  abort ;
  249.  
  250. : :F  Here @pfa  (patch)  [Compile] ]> ;
  251.  
  252. : ;F  Compile ;s  [Compile]  <[ ; Immediate
  253.  
  254. \ define a Value - a multiple-cfa structure that responds to
  255. \ Put, ++ and its default action is a fetch
  256. : Value
  257.     Header  here 12 allot 'c base
  258.     swap 12 cmove , ;
  259.  
  260. \ a vect responds to Put, Get, and default action is execute
  261. : Vect
  262.     Header here 12 allot 'c vModel swap
  263.     12 cmove  , ;
  264.  
  265. \ ( -- #cells)
  266. : mDepth  m0  mp@ - 4 / ;
  267. : rDepth  r0  rp@ - 4 / 2- ;    \ 2- accounts for threading of rDepth & rp@
  268.  
  269. : errBeep  5 beep ;
  270.  
  271. \ ( ^obj -- )
  272. : .ClassName  cfa @ nfa .name ;
  273.  
  274. \ Error routine for objects prints class name first
  275. \ Only valid inside of a method.
  276. : (classErr")
  277.     w@(IP) swap
  278.     IF  cr  msg# 104
  279.         copym .className  copym .h space die
  280.     ELSE  drop  THEN ;
  281.  
  282. : classErr"  Compile (classerr") @val w, ; Immediate
  283.  
  284. -39 Constant EOF
  285.  
  286. \ pseudo-assembler macros
  287. : popD0        $ 201F w, ; Immediate    \ MOVE.L (A7)+,D0
  288. : popA0        $ 205F w, ; Immediate    \ MOVE.L (A7)+,A0
  289. : pushD0    $ 2F00 w, ; Immediate    \ MOVE.L D0,-(A7)
  290. : pushA0    $ 2F08 w, ; Immediate    \ MOVE.L A0,-(A7)
  291. : next,        $ 4EEB w,  next w, ; Immediate
  292.  
  293. \ Define these code words above the nucleus
  294. \ this allows getMtxt to Find them at run time on a sealed nucleus
  295. Create null next,
  296. Create bye $ a9f4 w,
  297.  
  298. \ ( abs:addr len -- )  map string to upper case
  299. Create >uc
  300.     popD0
  301.     popA0
  302.     $ a054 w,    \ call uprString
  303.     next,
  304.  
  305. \ primitive ascii to binary conversion
  306. hex
  307. create (asc>bin)    ( str255 -- n)
  308.     2057    w,        \ movea.l    (sp),a0
  309.     3f3c0001 ,        \ move.w    #1,-(sp)
  310.     7001     w,        \ moveq        #1,d0
  311.     a9ee     w,        \ call pack7
  312.     2e80     w,        \ move.l    d0,(sp)
  313. next,
  314.  
  315. : asc>bin ( addr len -- n) str255 (asc>bin) ;
  316.  
  317. \ string is put into pad
  318. hex
  319. create bin>asc        ( n -- addr len )
  320.     201f      w,            \ move.l    (sp)+,d0
  321.     207c w, pad ,        \ movea.l    YERK[pad],a0
  322.     d1cb     w,            \ adda.l    a3,a0
  323.     3f3c0000 ,            \ move.w    #0,-(sp)
  324.     a9ee      w,            \ _numToString
  325.     4280      w,            \ clr.l        d0
  326.     1018      w,            \ move.b    (a0)+,d0
  327.     91cb      w,            \ suba.l    a3,a0
  328.     2f08      w,            \ move.l    a0,-(sp)
  329.     2f00     w,            \ move.l    d0,-(sp)
  330. next,
  331. decimal
  332.  
  333. \ ( fcb ftype signature -- )  Set file type and signature
  334. : file-install
  335.     >R >R DUP $ A00C (fdos) DROP
  336.     R> OVER $ 20 + !        \ set file type
  337.     R> OVER $ 24 + !        \ set signature
  338.     DUP $ A00D (fdos) DROP
  339.         $ A013 (fdos) DROP ;
  340.  
  341. \ =============== FCB words ===================
  342. \ ( fcb -- )  Set file pointer in the FCB
  343. : Set-file    dup 144 + +base swap !fptr ;
  344.  
  345. \ ( fcb -- )  Erase a parm block
  346. : ClrFCB  dup 144 erase dup 144 + 64 blanks set-file ;
  347.  
  348. \ ( addr len fcb -- )  store filename in fcb
  349. : !fname  dup clrFcb swap 64 min swap 144 + >str255 drop ;
  350.  
  351. \ ( fcb -- )  Get filename from stream
  352. : setName  word" count rot !fName ;
  353.  
  354. \ ==========  Various utility words needed  later
  355.  
  356. \ Become allows restarting at a given word, assuring that all stacks
  357. \ are empty.  This is necessary in menu handlers and other areas
  358. \ that could create indefinite nesting situations.
  359. 'c quit Vect becomeCFA
  360.  
  361. : Bi  sp! rp! mp!  becomeCfa quit ;
  362.  
  363. : (be)  R> @ put becomeCfa bi ;
  364.  
  365. \ use: Become newWord - compiles code to Be at runtime
  366. : Become
  367.     @pfa cfa State
  368.     IF  Compile (be) , ELSE put becomeCfa bi THEN
  369. ; Immediate
  370.  
  371. cLen CONSTANT CFALEN
  372. \ stack compiled list of values starting at IP
  373. : (lits)
  374.     R> dup w@  4* swap 2+ swap over +
  375.     dup   >R  swap
  376.     DO i@ 4 +LOOP ;
  377.  
  378. \ ( #lits -- #lits )  Compile header for list of literals if compile state
  379. : ,(lits)   state IF 'c (Lits) , dup W, THEN  ;
  380.  
  381. \ state-smart word to compile or stack a list of cfas
  382. \ ( #cfas -- )  pull words from stream and compile cfas
  383. : 'cfas
  384.     ,(lits) 0
  385.     DO  @pfa cfa  State IF , THEN LOOP
  386. ; Immediate
  387.  
  388. \ ( len -- )  Clear and allocate at here
  389. : Reserve   Here over erase allot ;
  390.  
  391. \ String constant leaves Addr Len at runtime
  392. : Scon
  393.     <Builds  word" Str,
  394.     Does>  Count ;
  395.  
  396. \ ( addr1 len1 addr2 len2 -- b )  String compare
  397. : S=
  398.     >R  Swap R>  Over =
  399.     IF  (s=)  ELSE 2drop drop 0 THEN ;
  400.  
  401. \ ( adr chr -- adrnext adr len )  Parser
  402. : parse
  403.     enclose
  404.     4 pick + 2swap >R R + rot R> -
  405. ;
  406.  
  407. \ CASE should be used for non-contiguous values.
  408. \ this is a modified  Eaker/Duncan model.
  409. \ ofBr takes branch at IP 1 nest back, and preserves val if
  410. \ branch taken, else it is dropped.
  411. : Case   ?Comp  csp !Csp  4 ; Immediate
  412.  
  413. \ ( val tst -- )  ofBr will take branch if 0 is on stack
  414. : (of) over = ofBr ;
  415.  
  416. \ ( val loTst hiTst -- )  Branch if not within inclusive range
  417. : (rof)   rot >R R >= swap R <= And R> swap  ofBr ;
  418.  
  419. : Of     4 ?Pairs Compile (of) Here 0, 5 ; Immediate
  420.  
  421. : rangeOf  4 ?Pairs Compile (rof) Here 0, 5 ; Immediate
  422.  
  423. : EndOf  5 ?Pairs Compile Branch Here 0,
  424.      swap 2 [Compile] THEN 4 ; Immediate
  425.  
  426. : EndCase  4 ?Pairs Compile drop
  427.     BEGIN  sp@  csp  = not
  428.     WHILE  2 [Compile] THEN
  429.     REPEAT   Put csp  ; Immediate
  430.  
  431. \ the Select structure should be used when dispatching execution
  432. \ on contiguous indices starting at 0.  It is smaller and faster
  433. \ than the equivalent CASE construct.
  434. \ An indexed CASE construct for compact, fast execution
  435. \ Runtime word for indexed case execution
  436.  
  437.  -1 Value CaseIndex
  438.  
  439. : (Select)
  440.     Abs R>  @ Dup 4+ >R  Swap  1+
  441.     4* Over Swap - Swap @ Max  @  >R ;
  442.  
  443. \ Begin an indexed case structure - see Forth Dimensions vII p.51
  444. : Select{
  445.     Compile (Select)  Here 0, 0  0 Put CaseIndex
  446.     [Compile]  <[
  447. ; Immediate
  448.  
  449. : Is{
  450.     ?Exec CaseIndex -
  451.     ?error 102
  452.     CaseIndex  1+ put caseIndex
  453.     240  [Compile] ]>
  454. ; Immediate
  455.  
  456. : }End
  457.     240 ?Pairs
  458.     Compile  ;S [Compile] <[  Here
  459. ; Immediate
  460.  
  461. : Default{
  462.     [Compile]  ]>
  463. ; Immediate
  464.  
  465. : }Select
  466.     [Compile] ]>   Compile  ;S  ,  Here  Pushm
  467.     BEGIN  Dup   WHILE  ,  REPEAT  Drop
  468.     Dup 4+ ,  Here Swap !  PopM  4-  ,
  469. ; Immediate
  470.  
  471. <" Args
  472.